home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / network / info-sys / www / tkhtml-2.3 / tkhtml-2 / tkHTML-2.3 / tix / Intrinsc.tcl < prev    next >
Encoding:
Text File  |  1995-02-12  |  7.6 KB  |  316 lines
  1. # The Tix Intrinsics
  2.  
  3. proc tixInt_CreateWidget {w class className args} {
  4.     upvar #0 $w data
  5.     upvar #0 $class classRec
  6.  
  7.     # CREATE CLASS RECORD IF NECESSARY
  8.     if {[info globals $class] == ""} {
  9.     tixInt_CreateClassRec $class
  10.     }
  11.  
  12.     tixInt_CreateWidgetRec        $w $class $className
  13.     eval $class::CreateWidgetRoot $w
  14.     tixInt_MkWidgetCommand        $w
  15.  
  16.     if {$classRec(rootOptions) == {}} {
  17.     foreach option [$data(rootCmd) config] {
  18.         lappend classRec(rootOptions) [lindex $option 0]
  19.     }
  20.     }
  21.  
  22.     # CREATE WIDGET RECORD
  23.     eval tixInt_LoadOptions       $w $class $className $args
  24.  
  25.     # INITIALIZE
  26.     eval $class::InitWidgetRec    $w $class $className $args 
  27.     eval $class::ConstructWidget  $w
  28.     eval $class::SetBindings      $w
  29.  
  30.     bind $w <Destroy> "+tixDeleteWidgetCmd $w"
  31. }
  32.  
  33. proc tixInt_CreateClassRec {class} {
  34.     $class::CreateClassRec
  35.     tixInt_CreateDefMethods $class
  36. }
  37.  
  38. proc tixInt_CreateWidgetRec {w class className} {
  39.     upvar #0 $w data
  40.     upvar #0 $class classRec
  41.  
  42.     set data(class)     $class
  43.     set data(className) $className
  44.     set data(root)      $w
  45. }
  46.  
  47. proc tixInt_LoadOptions {w class className args} {
  48.     upvar #0 $w data
  49.     upvar #0 $class classRec
  50.  
  51.     # SET UP THE WIDGET RECORD ACCORDING TO DEFAULT VALUES
  52.  
  53.     foreach option $classRec(options) {
  54.     if {[lindex $classRec($option) 0] == "="} {
  55.         continue
  56.     }
  57.  
  58.     set o_name    [lindex $classRec($option) 1]
  59.     set o_class   [lindex $classRec($option) 2]
  60.     set o_default [lindex $classRec($option) 3]
  61.  
  62.     set userDef [option get $w $o_name $o_class]
  63.     if {$userDef != ""} {
  64.         set data($option) $userDef
  65.     } else {
  66.         set data($option) $o_default
  67.     }
  68.     }
  69.  
  70.     # SET UP THE WIDGET RECORD ACCORDING TO COMMAND ARGUMENTS
  71.     set len  [llength $args]
  72.     set len2 [expr {$len - 2}]
  73.     set i 0
  74.     set root_options {}
  75.  
  76.     while {$i <= $len2} {
  77.     set option [lindex $args $i]
  78.     incr i
  79.     set arg [lindex $args $i]
  80.     incr i
  81.     
  82.     if {[lsearch $classRec(options) $option] != "-1"} {
  83.         if {[lindex $classRec($option) 0] != "="} {
  84.         set data($option) $arg
  85.         } else {
  86.         set realOption [lindex $classRec($option) 1]
  87.         set data($realOption) $arg
  88.         }
  89.     } else {
  90.         if [catch {$data(rootCmd) config $option $arg} err_msg] {
  91.         if {[string range $err_msg 0 13] == "unknown option"} {
  92.             error "unknown option $option. Should be: \
  93.                            [tixInt_ListOptions $w]"
  94.         } else {
  95.             error $err_msg
  96.         }
  97.         }
  98.     }
  99.     }
  100.  
  101.     if {$i != $len} {
  102.     error "Odd number of config parameters applied to $data(root)"
  103.     }
  104. }
  105.  
  106. proc tixInt_MkWidgetCommand {w} {
  107.     upvar #0 $w data
  108.  
  109.     set data(rootCmd) $w:root
  110.     tixRenameWidgetCmd $w $data(rootCmd)
  111.  
  112.     proc $w {method args} {
  113.     #------------------------------------------------------------
  114.     # the name of the data structure is the same as the procedure
  115.     #------------------------------------------------------------
  116.     set w [lindex [info level 0] 0]
  117.     upvar #0 $w data
  118.     upvar #0 $data(class) classRec
  119.  
  120.     case $method in {
  121.         #------------------------------------------------------------
  122.         # Config is a special method that needs special attention
  123.         #------------------------------------------------------------
  124.         {config configure} {
  125.           if {$args == {}} {
  126.         return [tixInt_QueryOptions $w]
  127.           }
  128.           if {[llength $args] == 1} {
  129.           if [catch {
  130.               return [tixInt_QueryOption $w [lindex $args 0]]
  131.               } e_msg] {
  132.               return -code error $e_msg
  133.               }
  134.           }
  135.           if [catch {eval tixInt_ApplyOptions $w $args} e_msg] {
  136.         return -code error $e_msg
  137.           }
  138.         }
  139.         default {
  140.         # 1. Execute the method as if it is a method of the class
  141.         # 2. If error happens in the execution of 1, check if
  142.         #    the method is supported by the class
  143.         # 3. If yes, then simply output the error message from 1.
  144.         # 4. If no, then try execute as if the method belogs 
  145.         #    to the root widget
  146.         # 5. If error in 4, check the following
  147.         # 6. If the method does belong to the root widget
  148.         #    simple print out the error message from 4.
  149.         # 7. If the method does not belong to the root widget
  150.         #    print the set of methods avilable from both the class
  151.         #    and the root widget
  152.  
  153.          if [catch {set ret [eval $data(class)::$method $w $args]} e_msg_1] {
  154.          if {[lsearch $classRec(methods) $method] != "-1"} {
  155.              # step 3
  156.              return -code error $e_msg_1
  157.          } elseif [catch {set ret [eval $data(rootCmd) $method $args]}\
  158.                e_msg_4] {
  159.              if {[lrange $e_msg_4 0 1] != "bad option"} {
  160.              # step 6
  161.              return -code error $e_msg_4 
  162.              } else {
  163.              # step 7
  164.              if {$classRec(methods) != ""} {
  165.                  foreach method $classRec(methods) {
  166.                  append e_msg_4 ", $method"
  167.                  }
  168.              }
  169.              return -code error $e_msg_4
  170.              }
  171.          }
  172.          # An original command executed OK
  173.          return $ret
  174.          }
  175.          # A valid method of the widget executed OK.
  176.          return $ret
  177.         }
  178.     }
  179.     }
  180. }
  181.  
  182.  
  183. proc tixInt_ListOptions {w} {
  184.     upvar #0 $w data
  185.     upvar #0 $data(class) classRec
  186.  
  187.     return [lsort "$classRec(rootOptions) $classRec(options)"]
  188. }
  189.  
  190. proc tixInt_QueryOptions {w} {
  191.     upvar #0 $w data
  192.     upvar #0 $data(class) classRec
  193.  
  194.     set options {}
  195.  
  196.     foreach option [$data(rootCmd) config] {
  197.     set flag [lindex $option 0]
  198.     if {[lsearch $classRec(options) $flag] == "-1"} {
  199.         lappend options $option
  200.     }
  201.     }
  202.  
  203.     foreach option $classRec(options) {
  204.     if {[lindex $classRec($option) 0] != "="} {
  205.         set opt $classRec($option)
  206.         lappend opt $data($option)
  207.         lappend options $opt
  208.     }
  209.     }
  210.  
  211.     return [lsort $options]
  212. }
  213.  
  214. proc tixInt_QueryOption {w option} {
  215.     upvar #0 $w data
  216.     upvar #0 $data(class) classRec
  217.  
  218.     if {[lsearch $classRec(options) $option] != -1} {
  219.     if {[lindex $classRec($option) 0] == "="} {
  220.         set option [lindex $classRec($option) 1]
  221.     }
  222.     set opt $classRec($option)
  223.     return [lappend opt $data($option)]
  224.     } else {
  225.     if [catch {return [$data(rootCmd) config $option]} err_msg] {
  226.         if {[string range $err_msg 0 13] == "unknown option"} {
  227.         error "unknown option $option. Should be: \
  228.                            [tixInt_ListOptions $w]"
  229.         } else {
  230.         error $err_msg
  231.         }
  232.     }
  233.     }
  234. }
  235.  
  236.  
  237. proc tixInt_ApplyOptions {w args} {
  238.     upvar #0 $w data
  239.     upvar #0 $data(class) classRec
  240.  
  241.     set len  [llength $args]
  242.     set len2 [expr {$len - 2}]
  243.     set i    0
  244.  
  245.     if {$len == 1} {
  246.     return [eval tixInt_QueryOption $w $args]
  247.     }
  248.  
  249.     while {$i <= $len2} {
  250.     set option [lindex $args $i]
  251.     incr i
  252.     set arg [lindex $args $i]
  253.     incr i
  254.  
  255.     if {[lsearch $classRec(options) $option] != "-1"} {
  256.         if {[lindex $classRec($option) 0] == "="} {
  257.         set option [lindex $classRec($option) 1]
  258.         }
  259.         set data($option) $arg
  260.         if {[info commands $data(class)::config$option] != ""} {
  261.         $data(class)::config$option $w $arg
  262.         }
  263.     } else {
  264.         if [catch {$data(rootCmd) config $option $arg} err_msg] {
  265.         if {[string range $err_msg 0 13] == "unknown option"} {
  266.             error "unknown option $option. Should be: \
  267.                            [tixInt_ListOptions $w]"
  268.         } else {
  269.             error $err_msg
  270.         }
  271.         }
  272.     }
  273.     }
  274.  
  275.     if {$i != $len} {
  276.     error "value for \"$option\" missing"
  277.     }
  278. }
  279.  
  280. proc tixInt_DefCreateWidgetRoot {w} {
  281.     upvar #0 $w data
  282.  
  283.     frame $w -class $data(className)
  284. }
  285.  
  286. # CREATE THE DEFAULT METHODS
  287. proc tixInt_CreateDefMethods {class} {
  288.  
  289.     if {[auto_load $class::CreateWidgetRoot] == 0} {
  290.     proc $class::CreateWidgetRoot {w} {
  291.         tixInt_DefCreateWidgetRoot $w
  292.     }
  293.     }
  294.  
  295.     if {[auto_load $class::InitWidgetRec] == 0} {
  296.     proc $class::InitWidgetRec {w class className args} {}
  297.     }
  298.  
  299.     if {[auto_load $class::SetBindings] == 0} {
  300.     proc $class::SetBindings {w} {}
  301.     }
  302. }
  303.  
  304. proc tixRenameWidgetCmd {w new_w} {
  305.     if {[info commands $new_w] != {}} {
  306.     rename $new_w {}
  307.     }
  308.     rename $w $new_w
  309. }
  310.  
  311. proc tixDeleteWidgetCmd {w} {
  312.     if {[info commands $w] != {}} {
  313.     rename $w {}
  314.     }
  315. }
  316.